﻿'   VBA Extractor - exports VB source code from macro enabled Word and Excel documents
'   Copyright (c) 2013 Tony Jollans & Neil Dodson

'   This program is free software; you can redistribute it and/or
'   modify it under the terms of the GNU General Public License
'   as published by the Free Software Foundation; either version 2
'   of the License, or (at your option) any later version.

'   This program is distributed in the hope that it will be useful,
'   but WITHOUT ANY WARRANTY; without even the implied warranty of
'   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
'   GNU General Public License for more details.

'   You should have received a copy of the GNU General Public License
'   along with this program; if not, write to the Free Software
'   Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.

Imports System.IO
Imports Microsoft.VisualBasic
Imports System.Runtime.InteropServices
Imports System.Text
Imports System.Reflection

Public Class Extractor
     
    Public Event Message(sender As Object, e As ParserEventArgs)
     
    Private Sub OnMessage(ByVal Message As String)
        RaiseEvent Message(Me, New ParserEventArgs(Message))
    End Sub

    Private ProjectRecordSeries As RecordSeries

    Private Project As ProjectInformation
    Private References() As ProjectReferences
    Private Modules() As ProjectModules

    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
    ' Some module level declarations make life a little easier.                             '
    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
    Private sourceFile As String
    Private str As Stream
    Private FileHeader As StructuredStorageHeader
    Private SAT() As Int32
    Private SSAT() As Int32
    Private Directory() As DirectoryEntryLocal
    Private SSStream As StreamOfShortSectors

    Public Sub Seek(ByVal Offset As Int32)
        str.Seek(Offset - 1, SeekOrigin.Begin)
    End Sub

    Public Sub GetStruct(Of T As Structure)(ByRef Struct As T)
        Dim size As Int32 = StructLen(Of T)()
        Dim buffer As Byte()
        ReDim buffer(size)
        str.Read(buffer, 0, size)
        Dim handle As GCHandle = GCHandle.Alloc(buffer, GCHandleType.Pinned)
        Struct = Marshal.PtrToStructure(handle.AddrOfPinnedObject(), GetType(T))
        handle.Free()
    End Sub

    Public Function StructLen(Of T As Structure)() As Int32
        Return Marshal.SizeOf(GetType(T))
    End Function

    Public Sub New(ByVal SourceFile As String)
        Me.sourceFile = SourceFile
    End Sub

    Public Function Execute() As List(Of Vb6File)

        Dim finder As VbaComponentFinder = New VbaComponentFinder(sourceFile)
        str = finder.VbaFileStream
        Try
            OnMessage("Starting..")
            Dim files As List(Of Vb6File) = GetOutputFiles()
            OnMessage("Done")
            Return files
        Finally
            finder.Dispose()
        End Try
    End Function

    Private Function GetOutputFiles() As List(Of Vb6File)

        Dim theStream() As Byte
        Dim DeCompressedData() As Byte

        Dim Compndx As Int32

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' Positioning the file at the beginning for clarity, read the File Header.    '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        Seek(1)

        OnMessage("Parsing Ole File..")

        GetStruct(Of StructuredStorageHeader)(FileHeader)

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' Gather the structural elements of the file, to enable what follows.         '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        Try

	        ExtractSAT()
	        ExtractSSAT()
	        ExtractDirectory()
	        ExtractShortSectorStream()
        Catch  
            Throw New ApplicationException(" Not a valid structured storage file (e.g. Excel 2.0 Worksheets legacy format)")
        End Try

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' Everything is now in place to extract any Stream we want by following the   '
        ' appropriate pointers. For this example, the "dir" Stream is extracted.      '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        OnMessage("Parsing VBA contents..")

        theStream = ExtractStream("dir")

        Compndx = 1
        Call DecompressContainer(theStream, Compndx, DeCompressedData)

        Call ExtractdirData(DeCompressedData)
        Dim ndx, i As Int32


        OnMessage("Creating output types..")

        Dim outputFiles As New List(Of Vb6File)
        Dim VbpManifest As New Vb6ProjectFile

        outputFiles.Add(VbpManifest)

        With VbpManifest
            .Name = Project.Name
            .FileName = Project.Name
            .Attributes.Add("Type", "OleDll")
            .Attributes.Add("Startup", "(None)")

            For Each ref In References
                If Not ref Is Nothing Then
                    Dim reg As LibId = ref.Registered.LibId

                    If Not String.IsNullOrEmpty(reg.RegName) Then


                        Dim comRef = New ActiveXReference
                        With comRef
                            .Name = reg.RegName
                            .MajorVersion = reg.MajorVersion
                            .MinorVersion = reg.MinorVersion
                            .Lcid = reg.Lcid
                            .HintPath = reg.Path
                            .Guid = reg.GUIDString

                        End With

                        .References.Add(comRef)
                    End If
                End If
            Next ref

            'Following are hacks to get the project to compile in vb6..

            'If you need to, add these office dll as references - they're implicitly referenced
            'from within the office application environments, but compilation may fail in the
            'extracted project if you don't have them. These ones are office 2010

            ''MSO.DLL 

            If (Not (.References.Any(Function(n) n.Guid.ToUpper().Contains("2DF8D04C-5BFA-101B-BDE5-00AA0044DE52")))) Then
                .References.Add(New ActiveXReference With {
                    .Name = "Microsoft Office 14.0 Object Library",
                    .MajorVersion = "2",
                    .MinorVersion = "0",
                    .Lcid = "0",
                    .Guid = "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}"})
            End If

            Dim fileName As String = sourceFile.ToLower

            If fileName.Contains(".xls") Then
                'EXCEL.EXE 
                If (Not (.References.Any(Function(n) n.Guid.ToUpper().Contains("00020813-0000-0000-C000-000000000046")))) Then
                    .References.Add(New ActiveXReference With {
                          .Name = "Microsoft Excel 14.0 Object Library",
                          .MajorVersion = "1",
                          .MinorVersion = "7",
                          .Lcid = "0",
                          .Guid = "{00020813-0000-0000-C000-000000000046}"})
                End If
            End If

           
            If fileName.Contains(".doc") Then

                'MSWORD.OLB
                If (Not (.References.Any(Function(n) n.Guid.ToUpper().Contains("00020905-0000-0000-C000-000000000046")))) Then
                    .References.Add(New ActiveXReference With {
                           .Name = "Microsoft Word 14.0 Object Library",
                           .MajorVersion = "8",
                           .MinorVersion = "5",
                           .Lcid = "0",
                           .Guid = "{00020905-0000-0000-C000-000000000046}"})
                End If
            End If

            'also make the output project compilable by specifying a public class
            Dim dummyClass = New Vb6Class( _
            "Attribute VB_Name = ""PublicClass""" & vbCrLf & _
            "Attribute VB_GlobalNameSpace = False" & vbCrLf & _
            "Attribute VB_Creatable = True" & vbCrLf & _
            "Attribute VB_PredeclaredId = False" & vbCrLf & _
            "Attribute VB_Exposed = True" & vbCrLf)
            dummyClass.Name = "PublicClass"
            dummyClass.FileName = "PublicClass"

            outputFiles.Add(dummyClass)
            VbpManifest.SourceFiles.Add(dummyClass)

        End With

        For ndx = 1 To UBound(Modules)
            With Modules(ndx)
                theStream = ExtractStream(.Name)
                For i = 1 To UBound(theStream) - .Offset
                    theStream(i) = theStream(i + .Offset)
                Next i

                ReDim Preserve theStream(UBound(theStream) - .Offset)
                Compndx = 1
                Call DecompressContainer(theStream, Compndx, DeCompressedData)

                Dim code As String = New ASCIIEncoding().GetString(DeCompressedData)
                Dim file As SourceFile = CreateFile(.Type, .Name, .Name, code)

                VbpManifest.SourceFiles.Add(file)
                outputFiles.Add(file)

            End With
        Next ndx

        Return outputFiles
    End Function

    Function ExtractStream(StreamName As String) As Byte()

        Dim UseShortStream As Boolean

        Dim Stream() As Byte

        Dim Sectorndx As Int32

        Dim Sector As NonSpecificSector
        Dim SectorNo As Int32
        Dim SectorLen As Int32

        Dim ndx As Int32
        Dim ndx2 As Int32

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' This routine scans the directory for an entry for a requested stream, and,  '
        ' assuming it's found, then extracts the data for that stream.                '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        For ndx = LBound(Directory) To UBound(Directory)
            If Directory(ndx).EntryType = Directory_EntryType.STGTY_Stream Then
                If Directory(ndx).EntryName = StreamName Then
                    Exit For
                End If
            End If
        Next

        If ndx > UBound(Directory) Then Return Nothing


        UseShortStream = (Directory(ndx).StreamLength < 4096)

        SectorLen = IIf(UseShortStream, StructLen(Of ShortSector)(), StructLen(Of NonSpecificSector)())

        ReDim Stream(0 To SectorLen - 1)

        Sectorndx = 0
        SectorNo = Directory(ndx).FirstSector

        Do While SectorNo >= 0

            If UseShortStream Then
                For ndx2 = 0 To SectorLen - 1
                    Stream(Sectorndx + ndx2) = _
                        SSStream.ShortSector(SectorNo).SSByte(ndx2)
                Next
            Else
                Seek((SectorNo + 1) * SectorLen + 1)
                GetStruct(Of NonSpecificSector)(Sector)
                For ndx2 = 0 To SectorLen - 1
                    Stream(Sectorndx + ndx2) = Sector.SectorByte(ndx2)
                Next
            End If

            Sectorndx = Sectorndx + SectorLen
            ReDim Preserve Stream(0 To UBound(Stream) + SectorLen)

            If UseShortStream Then
                SectorNo = SSAT(SectorNo)
            Else
                SectorNo = SAT(SectorNo)
            End If

        Loop

        ReDim Preserve Stream(Directory(ndx).StreamLength - 1)

        Return Stream

    End Function

    Sub ExtractSAT()

        Dim MSAT() As Int32
        Dim MSATndx As Int32
        Dim SATndx As Int32

        Dim Sector As SectorOfDWords
        Dim SectorNo As Int32
        Dim SectorLen As Int32
        Dim SectorEntries As Int32

        Dim ndx As Int32

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' First get the Master Sector Allocation Table. Make the array big enough for '
        ' the maximum possible entries because the code logic is easier that way.     '
        ' Read the first 109 entries from the header, then as many complete sectors   '
        ' as there are, before redefining the array to drop the excess entries.       '
        ' Note: The construct processed here is not explained in the article.         '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        If (FileHeader.csectDif * 127 + 108) > New FileInfo(sourceFile).Length Then 'hack to prevent massive array allocation
            Throw New ApplicationException("invalid sector allocation table")
        End If

        ReDim MSAT(0 To FileHeader.csectDif * 127 + 108)

        MSATndx = 0

        For MSATndx = 0 To 108
            MSAT(MSATndx) = FileHeader.sectFat(MSATndx)
        Next MSATndx
        SectorNo = FileHeader.sectDifStart

        Do While SectorNo >= 0

            Seek((SectorNo + 1) * 512 + 1)
            GetStruct(Of SectorOfDWords)(Sector)

            For ndx = 0 To 126
                MSAT(MSATndx + ndx) = Sector.DWord(ndx)
            Next ndx
            MSATndx = MSATndx + 127

            SectorNo = Sector.DWord(127)

        Loop

        ReDim Preserve MSAT(0 To FileHeader.csectFAT - 1) ' Right size

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' Read the sectors in the MSAT to build up the full Sector Allocation Table.  '
        ' The final sector may be padded with values of -1, but they should never be  '
        ' referenced. Once the SAT has been built, the MSAT is no longer needed.      '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        SectorLen = 512
        SectorEntries = 128 ' could calculate

        ReDim SAT(0 To SectorEntries * (UBound(MSAT) - LBound(MSAT) + 1) - 1)
        SATndx = 0

        For MSATndx = LBound(MSAT) To UBound(MSAT)

            Seek((MSAT(MSATndx) + 1) * SectorLen + 1)
            GetStruct(Of SectorOfDWords)(Sector)


            For ndx = LBound(Sector.DWord) To UBound(Sector.DWord)
                SAT(SATndx + ndx) = Sector.DWord(ndx)
            Next
            SATndx = SATndx + SectorEntries

        Next MSATndx

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' The final sector won't be full, but will be padded, as on file.             '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

    End Sub

    Sub ExtractSSAT()

        Dim SSATndx As Int32

        Dim Sector As SectorOfDWords
        Dim SectorNo As Int32
        Dim SectorLen As Int32
        Dim SectorEntries As Int32

        Dim ndx As Int32

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' The first sector of the Short Sector Allocation Table is held in the Header.'
        ' The rest are then chained through the SAT, built in the previous step. The  '
        ' end-of-chain is indicated by a value of -2 (0xFFFFFFFE) in the SAT. As with '
        ' the SAT, the final sector may be padded with values of -1, but they should  '
        ' never be referenced.                                                        '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        SectorLen = 512
        SectorEntries = 128 ' could calculate

        ReDim SSAT(0 To SectorEntries * FileHeader.csectMiniFat - 1)
        SSATndx = 0

        SectorNo = FileHeader.sectMiniFatStart

        Do While SectorNo >= 0

            Seek((SectorNo + 1) * SectorLen + 1)
            GetStruct(Of SectorOfDWords)(Sector)

            For ndx = LBound(Sector.DWord) To UBound(Sector.DWord)
                SSAT(SSATndx + ndx) = Sector.DWord(ndx)
            Next
            SSATndx = SSATndx + SectorEntries

            SectorNo = SAT(SectorNo)
        Loop

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' The final sector won't be full, but will be padded, as on file.             '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

    End Sub

    Sub ExtractDirectory()

        Dim Sector As DirectorySector
        Dim SectorNo As Int32
        Dim SectorLen As Int32
        Dim SectorEntries As Int32

        Dim ndx As Int32

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' The first sector of the Short Sector Allocation Table is held in the Header.'
        ' The rest are then chained through the SAT, built in the previous step. The  '
        ' end-of-chain is indicated by a value of -2 (0xFFFFFFFE) in the SAT. As with '
        ' the SAT, the final sector may be padded with values of -1, but they should  '
        ' never be referenced.                                                        '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        SectorLen = 512
        SectorEntries = 4 ' could calculate

        Erase Directory

        SectorNo = FileHeader.sectDirStart

        Do While SectorNo >= 0

            Seek((SectorNo + 1) * SectorLen + 1)

            GetStruct(Of DirectorySector)(Sector)

            For ndx = LBound(Sector.DirectoryEntry) To UBound(Sector.DirectoryEntry)

                With Sector.DirectoryEntry(ndx)
                    Select Case .mse : Case Directory_EntryType.STGTY_Root, Directory_EntryType.STGTY_Storage, Directory_EntryType.STGTY_Stream

                            If Directory Is Nothing Then
                                ReDim Directory(0 To 0)
                            Else
                                ReDim Preserve Directory(0 To UBound(Directory) + 1)
                            End If

                            Directory(UBound(Directory)).EntryName = Left(.ab, .cb - 2)
                            Directory(UBound(Directory)).EntryType = .mse
                            Directory(UBound(Directory)).LeftSibling = .sidLeftSib
                            Directory(UBound(Directory)).RightSibling = .sidRightSib
                            Directory(UBound(Directory)).RedOrBlack = .bflags
                            Directory(UBound(Directory)).RootChild = .sidChild
                            Directory(UBound(Directory)).FirstSector = .sectStart
                            Directory(UBound(Directory)).StreamLength = .ulSize

                    End Select
                End With
            Next

            SectorNo = SAT(SectorNo)

        Loop

    End Sub

    Sub ExtractShortSectorStream()

        Dim SSndx As Int32

        Dim Sector As SectorOfShortSectors
        Dim SectorNo As Int32
        Dim SectorLen As Int32
        Dim SectorEntries As Int32

        Dim ndx As Int32

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' The first sector of the Short Sector Stream is pointed to from the Root     '
        ' Storage directory entry; the rest are chained through the SAT. It seems as  '
        ' if one extra, unused, sector is allocated at the end of the stream; this is '
        ' simple observation, and I cannot confirm it to always be the case.          '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        SectorLen = 512
        SectorEntries = 8

        ReDim SSStream.ShortSector(0 To SectorEntries - 1)
        SSndx = 0

        SectorNo = Directory(0).FirstSector

        Do While SectorNo >= 0

            Seek((SectorNo + 1) * SectorLen + 1)
            GetStruct(Of SectorOfShortSectors)(Sector)

            With SSStream
                For ndx = LBound(Sector.ShortSector) To UBound(Sector.ShortSector)
                    .ShortSector(SSndx + ndx) = Sector.ShortSector(ndx)
                Next
                SSndx = SSndx + SectorEntries
                ReDim Preserve .ShortSector(0 To UBound(.ShortSector) + 8)
            End With

            SectorNo = SAT(SectorNo)
        Loop

    End Sub

    Sub DecompressContainer(ByRef CompressedContainer() As Byte, _
                            ByRef Compndx As Int32, _
                            ByRef DeCompressedData() As Byte)

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' This routine receives a Stream as a byte array, and an index into it, which '
        ' points to the start of a Compressed Container. There is nothing to indicate '
        ' where the container ends, so the only possible assumption, that it runs all '
        ' the way to the end of the Stream, is taken. The routine must also be passed '
        ' an empty byte array, which it will resize and fill with decompressed data.  '
        ' It is done this way to avoid the necessity of copying afterwards.           '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        Dim Decompndx As Int32
        Dim DecompLen As Int32

        Dim ChunkHeader As Int32
        Dim ChunkSignature As Int32
        Dim ChunkFlag As Int32
        Dim ChunkSize As Int32
        Dim ChunkEnd As Int32

        Dim BitFlags As Byte

        Dim Token As Int32
        Dim BitCount As Int32
        Dim BitMask As Int32
        Dim CopyLength As Int32
        Dim CopyOffset As Int32

        Dim ndx As Int32
        Dim ndx2 As Int32

        Dim PowerOf2(0 To 16) As Int32

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' A d****d irritating bit of initialisation. I have been having no end of     '
        ' trouble with "Expression too complex" errors, always seeming to be when I   '
        ' use exponentiation. To avoid them I pre-calculate the values and index into '
        ' the resulting array. Perchance this is actually an unintended optimisation, '
        ' although it would be better done, once, rather than every time, here.       '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        PowerOf2(0) = 1
        For ndx = 1 To UBound(PowerOf2)
            PowerOf2(ndx) = PowerOf2(ndx - 1) * 2
        Next

        Do  ' Once per chunk

            If DeCompressedData Is Nothing Then
                ReDim DeCompressedData(0 To 4095)
                Decompndx = 0
            Else
                ReDim Preserve DeCompressedData(UBound(DeCompressedData) + 4096)
            End If

            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
            ' The 16-bit chunk header contains the length of the chunk, and four flag     '
            ' bits. The high order bit is a flag (0 = uncompressed, 1 = compressed), and  '
            ' the next three bits must be 0b011.                                          '
            '                                                                             '
            ' VBA really isn't the language for bit twiddling and I am not going to fully '
            ' explain the code; you'll have to trust me when I say that these statements  '
            ' grab the desired bits and right align them!                                 '
            '                                                                             '
            ' If the Chunk Signature does not have a value of 3 (0b011), the chunk is     '
            ' invalid; the possibility of this is not considered in this routine.         '
            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

            ChunkHeader = CompressedContainer(Compndx) + _
                          256& * CompressedContainer(Compndx + 1)
            Compndx = Compndx + 2

            ChunkSize = (ChunkHeader And &HFFF)
            ChunkEnd = Compndx + ChunkSize
            ChunkSignature = (ChunkHeader And &H7000) \ &H1000&
            ChunkFlag = (ChunkHeader And &H8000) \ &H8000&

            If ChunkFlag = 0 Then

                ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                ' This just copies 4096 bytes from input to output. I would normally use the  '
                ' RtlMoveMemory API, but prefer not to use it in demonstration code, so this  '
                ' is a simple loop that copies a byte at a time. I have never seen a chunk    '
                ' that is not compressed, so am not unduly concerned about the inefficiency.  '
                ' I am - a little - concerned about what might happen when there are less     '
                ' than 4096 bytes but the compression routine decides not to compress; the    '
                ' documentation is silent on the issue so, maybe, it can't happen.            '
                ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

                For ndx2 = 0 To 4095
                    DeCompressedData(Decompndx + ndx2) = CompressedContainer(Compndx + ndx2)
                Next ndx2
                Compndx = Compndx + 4096
                Decompndx = Decompndx + 4096

            Else

                Do

                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                    ' The data in a chunk is a series of what are called Token Sequences.     '
                    ' Each Token Sequence consists of a byte to be viewed as eight separate   '
                    ' flag bits, followed by eight elements, the type of each being indicated '
                    ' by the individual flag bits. If a flag bit is 0, the corresponding      '
                    ' element is a single byte to be taken 'as is'; if the flag bit is 1, the '
                    ' element is a two byte code, which, after being unscrambled, gives the   '
                    ' position and length of a sequence earlier in the (decompressed) stream, '
                    ' which must be copied.                                                   '
                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

                    BitFlags = CompressedContainer(Compndx)
                    Compndx = Compndx + 1

                    For ndx = 0 To 7

                        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                        ' The final token sequence is not padded, and the chunk could end at  '
                        ' any point. Loop control, therefore, is here, rather than at the end.'
                        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

                        If Compndx > ChunkEnd Then Exit Do

                        If (BitFlags And PowerOf2(ndx)) = 0 Then

                            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                            ' A Literal Token: just copy the single-byte literal.             '
                            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

                            DeCompressedData(Decompndx) = CompressedContainer(Compndx)
                            Compndx = Compndx + 1
                            Decompndx = Decompndx + 1

                        Else

                            Token = CompressedContainer(Compndx) + _
                                    CompressedContainer(Compndx + 1) * 256&
                            Compndx = Compndx + 2

                            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                            ' A 16-bit Token consists of an offset (to the left, from the current '
                            ' position in the decompressed data), and a length (the number of     '
                            ' bytes to copy). The number of bits used for the offset (and, thus,  '
                            ' those used for the length) is the smallest integer that is greater  '
                            ' than the logarithm to base 2 of the length, so far, of the current  '
                            ' decompressed chunk subject to it never being less than 4 or greater '
                            ' than 12. Rather than use logs, this little loop has the constraints '
                            ' built in and stops at the appropriate point. As each chunk (bar the '
                            ' last) is exactly 4096 bytes long, the length so far of the current  '
                            ' decompressed chunk is as shown.                                     '
                            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

                            DecompLen = Decompndx Mod 4096

                            For BitCount = 4 To 11
                                If DecompLen <= PowerOf2(BitCount) Then Exit For
                            Next BitCount

                            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                            ' Having determined the number of bits dedicated to each component of '
                            ' the token, some bit twiddling is needed to extract the numbers. The '
                            ' offset first, then the length. No further explanation; work it out! '
                            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

                            BitMask = PowerOf2(16) - PowerOf2(16 - BitCount)
                            CopyOffset = (Token And BitMask) \ PowerOf2(16 - BitCount) + 1

                            BitMask = PowerOf2(16 - BitCount) - 1
                            CopyLength = (Token And BitMask) + 3

                            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                            ' Given the offset and the length, the copy can be done.              '
                            ' Note that the source and target may overlap.                        '
                            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

                            For ndx2 = 0 To CopyLength - 1
                                DeCompressedData(Decompndx + ndx2) _
                                        = DeCompressedData(Decompndx - CopyOffset + ndx2)
                            Next ndx2
                            Decompndx = Decompndx + CopyLength

                        End If  ' Literal Token or Copy Token

                    Next    ' Token

                Loop    ' For next Token Sequence

            End If  ' Was chunk compressed?

            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
            ' If not yet at the end of the Stream, the assumption is that there is        '
            ' another chunk: there is no possible information to the contrary.            '
            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

            If Compndx > UBound(CompressedContainer) Then Exit Do

        Loop

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' Only after having finished decompressing the final chunk is the final size  '
        ' known. Now the output array can be correctly sized.                         '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        ReDim Preserve DeCompressedData(0 To Decompndx - 1)

    End Sub

    Private Sub ExtractdirData(Stream() As Byte)

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' The dir Stream consists of a series of what Microsoft call Records that are '
        ' arranged, loosely, in a sort of hierarchy. The top level ones are called    '
        ' PROJECTINFORMATION, PROJECTREFERENCES, and PROJECTMODULES, and these are    '
        ' followed by a "Terminator" record with an ID of 0x0010, and a size of zero. '
        ' Several 'records' contain fields that "MUST be ignored"; whether they all   '
        ' really should be ignored is a moot point, but if they should, one can only  '
        ' wonder why they are present.                                                '
        ' Some, though not all, strings are held in both MBCS format and Unicode (and '
        ' one, rather oddly, twice in MBCS format). Although there may be some merit  '
        ' in doing this, in practice the MBCS strings do not appear to be correctly   '
        ' held, so no attempt is made to map them to the right code page. As the VB   '
        ' Editor has no capacity for input of characters that might require a multi-  '
        ' byte encoding, I rather suspect that Microsoft are being, shall we say,     '
        ' disingenuous with the MBCS suggestion, and I believe them to be, and treat  '
        ' them as, simple, single-byte, ANSI characters - until proved otherwise :-)  '
        ' Where possible, Unicode versions are extracted and MBCS ones ignored.       '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        Dim dirndx As Int32

        ProjectRecordSeries = RecordSeries.RecordSeries_PROJECTINFORMATION
        dirndx = 0

        Do ' While dirndx <= UBound(Stream)

            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
            ' This driver just calls other routines to do its work!                   '
            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

            Select Case ProjectRecordSeries
                Case RecordSeries.RecordSeries_PROJECTINFORMATION
                    ExtractInformation(Stream, dirndx)
                Case RecordSeries.RecordSeries_PROJECTREFERENCES
                    Erase References
                    ExtractReferences(Stream, dirndx)
                Case RecordSeries.RecordSeries_PROJECTMODULES
                    Erase Modules
                    ExtractModules(Stream, dirndx)
                Case RecordSeries.RecordSeries_TERMINATOR
                    Exit Do
                Case Else
                    Debug.Print("Unknown dir Stream Record")     ' Should never happen
                    Exit Do
            End Select

        Loop

    End Sub

    Private Sub ExtractInformation(ByRef Stream() As Byte, _
                                   ByRef ndx As Int32)

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' The PROJECTINFORMATION Record consists of a series of sub-records that are  '
        ' in sequence and are all always present. Although the documentation suggests '
        ' a rather more complex layout, the sub-records, with a single exception, are '
        ' all in the same format: a 2-byte ID, followed by a four byte size, followed '
        ' by data of that size; this is merely my interpretation, however, and things '
        ' may change in future releases.                                              '
        ' Although there is, as there always seems to be, a special case, one record  '
        ' where the "Size" is not the size (the Project Version Record - type 9), the '
        ' size of the 2-byte and 4-byte numeric values (Integers and Longs) is known, '
        ' and the size of String values is easily determinable, using Len or LenB  as '
        ' appropriate, so what is held in the stream can be ignored.                  '
        ' The absolute increments in the following code are: 2 for the length of the  '
        ' Record Id, and 6 for the combined length of Record Id and size.             '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        Dim Unicode As Boolean
 
        With Project

            .SysKind = GetInt32(Stream, ndx + 6)
            ndx = ndx + 6 + Len(.SysKind)

            .Lcid = GetInt32(Stream, ndx + 6)       ' Always 0x0409 = US English
            ndx = ndx + 6 + Len(.Lcid)

            .LcidInvoke = GetInt32(Stream, ndx + 6) ' Always 0x0409
            ndx = ndx + 6 + Len(.LcidInvoke)

            .Codepage = GetInt16(Stream, ndx + 6)    ' Always seems to be 1252
            ndx = ndx + 6 + Len(.Codepage)

            Unicode = False
            .Name = GetString(Stream, ndx + 6, GetInt32(Stream, ndx + 2), Unicode)
            ndx = ndx + 6 + Len(.Name)

            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
            ' Ignore the MBCS version of the PROJECTDOCSTRING (Microsoft's name for   '
            ' the Description), and just take the Unicode version.                    '
            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
            ndx = ndx + 6 + GetInt32(Stream, ndx + 2)
            Unicode = True
            .Description = GetString(Stream, ndx + 6, GetInt32(Stream, ndx + 2), Unicode)
            ndx = ndx + 6 + Len(.Description) * 2

            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
            ' After storing the PROJECTHELPFILEPATH value, ignore the duplicate value '
            ' on the PROJECTHELPFILEPATH2 sub-record.                                 '
            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
            Unicode = False
            .HelpFilePath = GetString(Stream, ndx + 6, GetInt32(Stream, ndx + 2), Unicode)
            ndx = ndx + 6 + Len(.HelpFilePath)
            ndx = ndx + 6 + GetInt32(Stream, ndx + 2)

            .HelpContext = GetInt32(Stream, ndx + 6)
            ndx = ndx + 6 + Len(.HelpContext)

            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
            ' The documentation for PROJECTLIBFLAGS, on the one hand, refers to the   '
            ' [MS-OAUT] documentation for Automation while, on the other hand, saying '
            ' that this must be 0x00000000. Who knows? Just extract it.               '
            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
            .LibFlags = GetInt32(Stream, ndx + 6)
            ndx = ndx + 6 + Len(.LibFlags)

            .VersionMajor = GetInt32(Stream, ndx + 6)
            .VersionMinor = GetInt16(Stream, ndx + 6 + Len(.VersionMajor))
            ndx = ndx + 6 + Len(.VersionMajor) + Len(.VersionMinor)

            Unicode = True
            ndx = ndx + 6 + GetInt32(Stream, ndx + 2)
            .Constants = GetString(Stream, ndx + 6, GetInt32(Stream, ndx + 2), Unicode)
            ndx = ndx + 6 + Len(.Constants) * 2

        End With

        ProjectRecordSeries = ProjectRecordSeries + 1

    End Sub

    Public Sub ExtractReferences(ByRef Stream() As Byte, _
                                 ByRef ndx As Int32)

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' The PROJECTREFERENCES Record contains sub-records for an indeterminate      '
        ' number of references. The basic logic is to extract the Record Id and the   '
        ' size, and then to process 'size' bytes appropriately according to the Id.   '
        ' Within each reference the sub-records, varying according to the type of the '
        ' reference, are in a fixed sequence and there are some dependencies on that  '
        ' sequence. In particular the NAME sub-record is always the first one, but    '
        ' NAME sub-records may also be embedded in extended references (see "Control" '
        ' records below), and a flag is maintained to indicate which may be the case. '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        Dim RecordId As Int16
        Dim size As Int32
        Dim LibIdSize As Int32

        Dim IsControlReference As Boolean

        Do

            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
            ' Extract the Record Id and Size, and increment the index into the chunk. '
            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

            RecordId = GetInt16(Stream, ndx)
            size = GetInt32(Stream, ndx + 2)
            ndx = ndx + 6

            Select Case RecordId

                ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                ' If not currently mid-process amongst the various sub-records that   '
                ' make up a Control Reference, a NAME sub-record signifies the start  '
                ' of a new reference, so the array is extended. Whichever case, the   '
                ' contents are in MBCS format and are ignored, preference being given '
                ' to the Unicode version that follows.                                '
                ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                Case RecordType.REFERENCENAME
                    If Not IsControlReference Then
                        If References Is Nothing Then
                            ReDim References(1)
                        Else
                            ReDim Preserve References(
                                                 UBound(References) + 1)
                        End If
                    End If
                Case RecordType.REFERENCENAMEUNICODE
                    References(UBound(References)) = New ProjectReferences
                    If Not IsControlReference Then
                        References(UBound(References)).Name = GetString(Stream, ndx, size, Unicode:=True)
                    Else
                        References(UBound(References)).Control.ExtendedName = GetString(Stream, ndx, size, Unicode:=True)
                    End If

                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                    ' Name records are followed by one of three further records: Control, '
                    ' Registered, or Project, all of which hold detail in structures      '
                    ' called "LibId"s. I don't really understand the need for all the     '
                    ' complication, but a Registered reference simply contains a LibId, a '
                    ' Project reference holds an "absolute" and a "relative" LibId, and a '
                    ' Control reference has a structure containing an "Original" record a '
                    ' "Twiddled" record, and an "Extended" record, each containing,       '
                    ' amongst other fields, a LibId.                                      '
                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                    ' The Reference Registered record contains a 4-byte Libid length, the '
                    ' LibId itself, and two fields, called "Reserved1" and "Reserved2",   '
                    ' which are, respectively, four and two bytes of binary zeroes.       '
                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                Case RecordType.REFERENCEREGISTERED
                    With References(UBound(References))
                        .Type = RecordType.REFERENCEREGISTERED
                        StoreLibid(.Registered.LibId, _
                                   GetString(Stream, ndx + 4, GetInt32(Stream, ndx), _
                                             Unicode:=False), _
                                   LibIdType.LibidTypeOrdinary)
                    End With

                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                    ' The Reference Project record contains a 4-byte length of its        '
                    ' "absolute" LibId and then the LibId itself, a 4-byte length of its  '
                    ' "relative" Libid, and then that Libid itself, followed by a major   '
                    ' version and a minor version. Although the documentation calls these '
                    ' "LibIds", they are not LibIds like the others; they are Project     '
                    ' References in a somewhat different format. Obfuscation seems to be  '
                    ' prevalent in the documentation as much as in the data.              '
                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                Case RecordType.REFERENCEPROJECT
                    With References(UBound(References))
                        .Type = RecordType.REFERENCEPROJECT
                        .Project = New ProjectReference
                        StoreProjectReference(.Project, Stream, ndx)
                    End With

                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                    ' The Reference Control record starts with an "Original" sub-record,  '
                    ' which should contain a 4-byte length of the original Libid, but     '
                    ' which may not exist. This is followed by a "Twiddled" sub-record    '
                    ' (please don't ask what twiddling is) which is just like a           '
                    ' Registered record, and this is then followed by an "Extended Name"  '
                    ' record (as per the "Name" record above).                            '
                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                Case RecordType.REFERENCEORIGINAL
                    With References(UBound(References))
                        .Type = RecordType.REFERENCECONTROL
                        StoreLibid(.Control.LibId(0), _
                                   GetString(Stream, ndx, size, Unicode:=False), _
                                   LibIdType.LibidTypeOrdinary)
                    End With
                    IsControlReference = True

                Case RecordType.REFERENCECONTROL
                    LibIdSize = GetInt32(Stream, ndx)
                    StoreLibid(References(UBound(References)).Control.LibId(1), _
                               GetString(Stream, ndx + 4, LibIdSize, Unicode:=False), _
                               LibIdType.LibidTypeTwiddled)

                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                    ' The final element of the control reference is the "Extended" record,'
                    ' another Libid, preceded by its size, and followed by a two fields,  '
                    ' a 4-byte "Reserved4" and a 2-byte "Reserved5", to be ignored, and   '
                    ' then a GUID (this time a 'real' one, not a string) and a "cookie".  '
                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                Case RecordType.REFERENCEEXTENDED
                    LibIdSize = GetInt32(Stream, ndx)
                    With References(UBound(References)).Control
                        StoreLibid(.LibId(2), _
                                   GetString(Stream, ndx + 4, LibIdSize, Unicode:=False), _
                                  LibIdType.LibidTypeExtended)
                        .OriginalTypeLib = GetGUID(Stream, ndx + 4 + LibIdSize + 6)
                        .OriginalTypeLibString = GUIDtoString(.OriginalTypeLib)
                        .Cookie = GetInt32(Stream, ndx + size - 4)
                    End With
                    IsControlReference = False

                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                    ' The only way to get here should be with a sub-record that does not  '
                    ' belong to a reference. In practice, this will be the first Modules  '
                    ' Record but, in theory, this routine has no knowledge of what comes  '
                    ' next, so it simply flags the end of its work and makes the record   '
                    ' ready for processing by any further logic there may be.             '
                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                Case Else
                    ProjectRecordSeries = ProjectRecordSeries + 1
                    ndx = ndx - 6
                    size = 0

            End Select ' Record Type

            ndx = ndx + size

        Loop While ProjectRecordSeries = RecordSeries.RecordSeries_PROJECTREFERENCES ' For next sub-record

    End Sub

    Public Sub ExtractModules(ByRef Stream() As Byte, _
                              ByRef ndx As Int32)

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' The PROJECTMODULES Record contains a series of sub-records for each module  '
        ' in the Project. The basic logic is the same as for the References (q.v.).   '
        ' There is an assortment of sub-records per module; they are in a particular  '
        ' sequence but the only real dependencies are that the count comes first and  '
        ' that the NAME sub-record is the first one for each individual module.       '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        Dim RecordId As Int16
        Dim size As Int32

        Dim ndxModule As Int32

        Do

            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
            ' Extract the Record Id and Size, and increment the index into the chunk. '
            ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

            RecordId = GetInt16(Stream, ndx)
            size = GetInt32(Stream, ndx + 2)
            ndx = ndx + 6

            Select Case RecordId

                ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                ' The first record contains a count of modules so the array can be    '
                ' set to the right dimensions immediately. The "Cookie" is irrelevant.'
                ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                Case RecordType.MODULESCOUNT
                    ReDim Modules(GetInt16(Stream, ndx))

                Case RecordType.PROJECTCOOKIE

                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                    ' NAME sub-records indicate a new module, so increment the index.     '
                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                Case RecordType.MODULENAME
                    ndxModule = ndxModule + 1
                    If Not String.IsNullOrWhiteSpace(Modules(ndxModule).Name) Then
                        Modules(ndxModule).Name = GetString(Stream, ndx, size, Unicode:=False)
                    End If

                Case RecordType.MODULENAMEUNICODE
                    Modules(ndxModule).Name = GetString(Stream, ndx, size, Unicode:=True)

                Case RecordType.MODULESTREAMNAME
                    If Not String.IsNullOrWhiteSpace(Modules(ndxModule).StreamName) Then
                        Modules(ndxModule).StreamName = GetString(Stream, ndx, size, Unicode:=False)
                    End If

                Case RecordType.MODULESTREAMNAMEUNICODE
                    Modules(ndxModule).StreamName = GetString(Stream, ndx, size, Unicode:=True)

                Case RecordType.MODULEDOCSTRING
                    If Not String.IsNullOrWhiteSpace(Modules(ndxModule).Description) Then
                        Modules(ndxModule).Description = GetString(Stream, ndx, size, Unicode:=False)
                    End If

                Case RecordType.MODULEDOCSTRINGUNICODE
                    Modules(ndxModule).Description = GetString(Stream, ndx, size, Unicode:=True)

                Case RecordType.MODULEOFFSET
                    Modules(ndxModule).Offset = GetInt32(Stream, ndx)

                Case RecordType.MODULEHELPCONTEXT
                    Modules(ndxModule).HelpContext = GetInt32(Stream, ndx)

                Case RecordType.MODULECOOKIE

                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                    ' Several Module sub-records contain no data, their presence, or      '
                    ' absence, indicating attributes of the module.                       '
                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                Case RecordType.MODULETYPEMODULERECORD
                    Modules(ndxModule).Type = ModuleType.ModuleTypeModule

                Case RecordType.MODULETYPECLASSMODULERECORD
                    Modules(ndxModule).Type = ModuleType.ModuleTypeClassModule

                Case RecordType.MODULEREADONLY
                    Modules(ndxModule).ReadOnly = True

                Case RecordType.MODULEPRIVATE
                    Modules(ndxModule).Private = True

                Case RecordType.MODULETERMINATOR

                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                    ' The only way to get here should be with a sub-record that does not  '
                    ' belong to a module. In practice, this can only be the terminator    '
                    ' Record but, in theory, this routine has no knowledge of what comes  '
                    ' next, so it simply flags the end of its work and makes the record   '
                    ' ready for processing by any further logic there may be.             '
                    ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
                Case Else
                    ProjectRecordSeries = ProjectRecordSeries + 1
                    ndx = ndx - 6
                    size = 0

            End Select ' Record Type

            ndx = ndx + size

        Loop While ProjectRecordSeries = RecordSeries.RecordSeries_PROJECTMODULES ' For next sub-record

    End Sub


    Private Sub StoreLibid(ByRef LibId As LibId, _
                           ByRef LibIdString As String, _
                           ByVal LibIdType As LibIdType)

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' References are stored in one sort or another of Reference record, and they  '
        ' all use a "LibId", a string of sub-fields, separated by "#" characters, the '
        ' only slight exception being the dot (period) that separates the major and   '
        ' minor versions. This simple routine just stores the separate sub-fields in  '
        ' order to keep the calling code as free from clutter as possible.            '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        Dim LibIdSplit As String()

        LibIdSplit = Split(LibIdString, "#")

        With LibId

            .Type = LibIdType

            .Kind = AscW(Mid$(LibIdSplit(0), 3, 1))
            .GUIDString = Mid$(LibIdSplit(0), 4)
            .MajorVersion = Split(LibIdSplit(1), ".")(0)
            .MinorVersion = Split(LibIdSplit(1), ".")(1)
            .Lcid = LibIdSplit(2)
            .Path = LibIdSplit(3)
            .RegName = LibIdSplit(4)

        End With

    End Sub

    Private Sub StoreProjectReference(ByRef Project As ProjectReference, _
                                      ByRef Stream() As Byte, _
                                      ByVal Streamndx As Int32)

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' This is not ideal but it moves a chunk of code out of the mainline. Project '
        ' references consist of an 'absolute' path, a 'relative' path, and major and  '
        ' minor versions (the real meaning of which I do not know).                   '
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        Dim size As Int32

        size = GetInt32(Stream, Streamndx)
        With Project.ProjectLibId(0)
            .Type = LibIdType.LibidTypeProjectAbsolute
            .Kind = Stream(Streamndx + 6)               ' Past size and "*\"
            .Path = GetString(Stream, Streamndx + 7, size - 3, Unicode:=False)
        End With
        Streamndx = Streamndx + 4 + size                ' Skip over absolute

        size = GetInt32(Stream, Streamndx)
        With Project.ProjectLibId(1)
            .Type = LibIdType.LibidTypeProjectRelative
            .Kind = Stream(Streamndx + 6)               ' Past size and "*\"
            .Path = GetString(Stream, Streamndx + 7, size - 3, Unicode:=False)
        End With
        Streamndx = Streamndx + size + 4                 ' Skip over relative

        Project.MajorVersion = GetInt32(Stream, Streamndx)
        Project.MinorVersion = GetInt16(Stream, Streamndx)

    End Sub

    Private Function GetGUID(ByRef Stream() As Byte, _
                             ByVal Streamndx As Int32) _
                     As GUID

        Dim ndx As Int32

        GetGUID = New GUID

        With GetGUID

            .Data1 = GetInt32(Stream, Streamndx)
            .Data2 = GetInt16(Stream, Streamndx + 4)
            .Data3 = GetInt16(Stream, Streamndx + 6)

            For ndx = 0 To 7
                .Data4(ndx) = Stream(Streamndx + 8 + ndx)
            Next ndx

        End With

    End Function

    Private Function GUIDtoString(ByRef GUID As GUID) As String

        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
        ' A simple conversion of a standard format GUID to its string representation. '
        ' This is not strictly necessary; it just makes life easier for human readers.'
        ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '

        Dim ndx As Int32

        With GUID

            GUIDtoString = "{" & Right("00000000" & Hex(.Data1), 8) & "-"
            GUIDtoString = GUIDtoString & Right("0000" & Hex(.Data2), 4) & "-"
            GUIDtoString = GUIDtoString & Right("0000" & Hex(.Data3), 4) & "-"

            For ndx = 0 To 7
                GUIDtoString = GUIDtoString & Right("00" & Hex(.Data4(ndx)), 2)
                If ndx = 1 Then GUIDtoString = GUIDtoString & "-"
            Next ndx

        End With

        GUIDtoString = GUIDtoString & "}"

    End Function

    Private Function GetInt16(ByRef Stream() As Byte, _
                            ByVal ndx As Int32) _
                     As Int16

        GetInt16 = Stream(ndx) + _
                 (Stream(ndx + 1) Mod 128) * 256& _
                 + (Stream(ndx + 1) >= 128) * 32768

    End Function

    Private Function GetInt32(ByRef Stream() As Byte, _
                             ByVal ndx As Int32) _
                     As Int32

        GetInt32 = Stream(ndx) + _
                  Stream(ndx + 1) * 256& + _
                  Stream(ndx + 2) * 65536 + _
                  (Stream(ndx + 3) Mod 128) * 16777216

        If (Stream(ndx + 3) >= 128) Then
            GetInt32 = GetInt32 - &H40000000 - &H40000000
        End If

    End Function

    Private Function GetString(ByRef Stream() As Byte, _
                               ByVal ndx As Int32, _
                               ByVal size As Int32, _
                               ByVal Unicode As Boolean) _
                     As String

        Dim bytes(0 To size - 1) As Byte
        Dim encoding As Encoding = IIf(Unicode, New UnicodeEncoding, New UTF8Encoding)

        Dim s = ndx
        For ndx = ndx To ndx + size - 1
            bytes(ndx - s) = Stream(ndx)
        Next ndx


        GetString = encoding.GetString(bytes)

    End Function


    'maps internal moduleType to external source file type
    Public Function CreateFile(ByVal fileType As ModuleType, _
                             ByVal name As String, _
                             ByVal FileName As String, _
                             ByVal code As String) As SourceFile

        Dim element As SourceFile

        Select Case fileType
            Case ModuleType.ModuleTypeClassModule
                element = New Vb6Class(code)
            Case ModuleType.ModuleTypeModule
                element = New Vb6Module(code)
            Case Else
                Throw New NotImplementedException()
        End Select

        element.Name = name
        element.FileName = FileName
        Return element

    End Function
End Class
